{$i-}
unit chanels;

{$ifdef fpc}{$asmmode intel}{$endif}

{$ifdef DPMI}{$define P386}{$endif}
{$ifdef Windows}{$define P386}{$endif}

interface
uses {$ifdef P386}DPMI,{$endif}
     {$ifdef Windows}Windos;{$else}dos;{$endif}

type UpravUsr=record	{ dodefinovana uzivatelska data ve strukture FILE }
	kod:Word;
	x,y,Dx,Dy:Word;
        curX,CurY:Word;
        color:Word;
       end;

     File2 = record        { predefinovana struktura fileRec }
        fHandle:Word;
        fMode:Word;
        fBufSize:Word;
	fPrivate:Word;
        fBufPos:Word;
	fBufEnd:Word;
        fBufPtr:Pointer;
        fOpenProc:Function (var t:text):Word;
        fInOutProc:Function (var t:text):Word;
        fFlushProc:Function (var t:text):Word;
	fCloseProc:Function (var t:text):Word;
        UserData:UpravUsr;
        case integer of
        	1:(fName:array[0..79] of char;
		   fBuffer:{$ifndef Windows}textBuf;{$else}TTextBuf;{$endif});
                2:(UkString:^string;pozice:char);
                3:(UkName:Pchar);
	end;

   type ukstring = ^string;
   type XSearchRec = record
        case integer of
         1:(Fill: array[1..21] of Byte;
	    Old_Attr: Byte;
	    Time: Longint;
	    Old_Size: Longint;
	    Old_Name: string[12];);
         2:(Attributes:Longint;
	    CTimeLo,CtimeHi:longint;
	    LATimeLo,LATimeHi:longint;
	    LMTimeLo,LMTimeHi:longint;
	    FilesizeHi,FileSizeLo:longint;
	    Reserved:Array[0..7]of byte;
	    FileName:array[0..259]of char;
	    SFilename:array[0..13]of char;

            FileFindHandle:word;

	    Name:ukstring;
            Size:longint;
	    SName:ukstring;
	    Attr: Longint);
   end;


Function NoOp(var t:text):Word;

{-------------Extended Text Operations--------------}
Function FilePosText(var txt:text):longint;
Procedure SeekText(var txt:text;x:longint);
Function BlockReadText(var txt:text;var buf;count:word):Word;
Procedure AddBuffer(var Txt:Text;buf:pointer;size:Word); {zmeni buffer textoveho souboru}
Function GetcharTXT(var txt:Text):char;		{precte 1 byte ze souboru}
Function readInt(var txt:Text;var c:char):Word;	{precte integer ze souboru}
Function readLong(var txt:Text;var c:char):longint; {precte longint ze souboru}
Function readWord(var txt:Text;var c:char):string;
Function ReadxByte(var Txt:Text):byte;	{precte 1 hexadecimalni cifru ze souboru}
Procedure WritexByte (w:byte;var txt:text);{vytiskne hexadecimalne 1 byte}
Procedure ReadLn2(var txt:text);


{---------Long filename support procedures----------}
Procedure Assign2(var f:file; s:String);
Procedure Assign2T(var t:text; s:String);
procedure FindFirst2(const Path: string; Attr: Word; var Search: XSearchRec);
function FileSplit2(Path, Dir, Name, Ext: PChar): Word;
Procedure FSplit2(Path: string;var Dir:string; var Name:string;var Ext:string);
procedure FindNext2(var Search: XSearchRec);
procedure FindClose2(var Search: XSearchRec);
Procedure MkDir2(dir:Pchar);
Procedure RmDir2(dir:Pchar);


{--------String oriented support functions---------}
Procedure string2Pchar(var as_);
Procedure Pchar2String(var as_);
{ FileSplit return flags }
const fcExtension = $0001;
      fcFileName  = $0002;
      fcDirectory = $0004;
      fcWildcards = $0008;

implementation
uses strings;
const Win95:Boolean=False;


{replacement for long name MkDir}
Procedure MkDir2(dir:Pchar); assembler;
asm
	mov	cl,byte ptr Win95
	Mov	ah,39h
	or	cl,cl
	jnz     @MkNorm
	Mov	ax,7139h
@MkNorm:push	ds
	lds	dx,dir
        int	21h
        pop	ds
        jnc	@end

        mov	InOutRes,AX		{error Occured}
        cmp	ax,7100h
	jne	@End
        mov	Win95,0
@End:
end;


{replacement for long name RmDir}
Procedure RmDir2(dir:Pchar); assembler;
asm
	mov	cl,byte ptr Win95
        Mov	ah,39h
	or	cl,cl
	jnz     @MkNorm
	Mov	ax,713Ah
@MkNorm:push	ds
        lds	dx,dir
	int	21h
        pop	ds
        jnc	@end

        mov	InOutRes,AX		{error Occured}
        cmp	ax,7100h
	jne	@End
        mov	Win95,0
@End:
end;


{replacement for long name assigning to file}
Procedure Assign2(var f:file; s:String);
var frec:File2 absolute f;
    src,dest:pointer;
begin
 Assign(f,s);

 if Win95 then
   begin
   dest:=addr(frec.fName);
   src:=addr(s[1]);
   s[length(s)+1]:=#0;
 	asm			{Shrink long path to the short 8.3 form}
        mov	ax,7160h
        mov	cl,1
        mov	ch,80h
        push	ds
        push	es
        les	di,dest
        lds	si,src
        int	21h
        pop	es
        pop	ds
	end;
   end;
end;


{replacement for long name assigning to file}
Procedure Assign2T(var t:text; s:String);
var {$ifndef Windows}
    txt:textrec absolute t;
    {$else}
    txt:TTextRec absolute t;
    {$endif}
    src,dest:pointer;
begin
 Assign(t,s);

 if Win95 then
   begin
   dest:=addr(txt.Name);
   src:=addr(s[1]);
   s[length(s)+1]:=#0;
 	asm			{Shrink long path to the short 8.3 form}
        mov	ax,7160h
        mov	cl,1
        mov	ch,80h
        push	ds
        push	es
        les	di,dest
        lds	si,src
        int	21h
        pop	es
        pop	ds
	end;
   end;
end;


{Input: ES:DI - string to be converted from pchar to string}
procedure FixString; assembler;
asm
	PUSH	DS
	PUSH	ES
	POP	DS
	XOR	AL,AL
	MOV	CX,256
	CLD
	REPNE	SCASB
	NOT	CL
	MOV	AL,CL
	DEC	DI
	MOV	SI,DI
	DEC	SI
	STD
	REP	MOVSB
	STOSB
	CLD
	POP	DS
end;


{replacement for long filename searching}
procedure FindFirst2(const Path: string; Attr: Word; var Search: XSearchRec); assembler;
var PathBuf:array[0..260] of char;
asm
	mov	cl,byte ptr Win95

	PUSH	DS
	LDS	SI,Path
	LEA	DI,PathBuf
	PUSH	SS
	POP	ES
	CLD
	LODSB

	or	cl,cl
        jnz     @Find95

	CMP	AL,79			;{standard DOS searching}
	JB	@@1
	MOV	AL,79
@@1:	CBW
	XCHG	AX,CX
	REP	MOVSB
	XOR	AL,AL
	STOSB
	LDS	DX,Search
	MOV	AH,1AH
	INT	21H
	LEA	DX,PathBuf
	PUSH	SS
	POP	DS
	MOV	CX,Attr
	MOV	AH,4EH
	INT	21H
	POP	DS
        JC	@@Finish

        LES	DI,Search
        MOV	AX,word ptr ES:[DI+XSearchRec.Old_Size]
        MOV	word ptr ES:[DI+XSearchRec.Size],AX
 	MOV	AX,word ptr ES:[DI+XSearchRec.Old_Size+2]
        MOV	word ptr ES:[DI+XSearchRec.Size+2],AX
        MOV	AL,byte ptr ES:[DI+XSearchRec.Old_Attr]
        MOV	AH,0
        MOV	word ptr ES:[DI+XSearchRec.Attr],AX
        MOV	AL,0
        MOV	word ptr ES:[DI+XSearchRec.Attr+2],AX
        MOV	SI,DI
        ADD	DI,XSearchRec.Old_Name
        ADD	SI,XSearchRec.Name
        MOV	word ptr ES:SI,DI
        MOV	AX,ES
        MOV	word ptr ES:SI+2,AX
        call    FixString

	XOR	AX,AX
        JMP     @@Finish

@Find95:CBW				;{windows95 long name searching}
	XCHG	AX,CX
	REP	MOVSB
	XOR	AL,AL
	STOSB
        LEA	DX,PathBuf
        MOV	AX,DS
        MOV	ES,AX
        LES     DI,Search
        MOV	CX,Attr
        MOV	SI,1
        MOV	AX,$714E
        INT	21H
        POP	DS

        JC	@@Finish
        LES	DI,Search
        MOV	word ptr ES:DI+XSearchRec.FileFindHandle,AX
        MOV	AX,word ptr ES:[DI+XSearchRec.FileSizeLo]
        MOV	word ptr ES:[DI+XSearchRec.Size],AX
 	MOV	AX,word ptr ES:[DI+XSearchRec.FileSizeLo+2]
        MOV	word ptr ES:[DI+XSearchRec.Size+2],AX
        MOV	AX,word ptr ES:[DI+XSearchRec.Attributes]
        MOV	word ptr ES:[DI+XSearchRec.Attr],AX
        MOV	AX,word ptr ES:[DI+XSearchRec.Attributes+2]
        MOV	word ptr ES:[DI+XSearchRec.Attr+2],AX
        MOV	SI,DI
        ADD	SI,XSearchRec.Name
        ADD	DI,XSearchRec.FileName
        MOV	word ptr ES:SI,DI
        MOV	AX,ES
        MOV	word ptr ES:SI+2,AX
        call	FixString
	XOR	AX,AX

@@Finish:MOV	DosError,AX
end;


{replacement for long filename searching - next record}
procedure FindNext2(var Search: XSearchRec); assembler;
asm
{SearchP		EQU	(DWORD PTR [BP+6])}
	mov	cl,byte ptr Win95
	or	cl,cl
        jnz     @Find95

	PUSH	DS
	LDS	DX,Search
	MOV	AH,1AH
	INT	21H
	POP	DS
	MOV	AH,4FH
	INT	21H
        JC	@@2
        LES	DI,Search
        MOV	AX,word ptr ES:[DI+XSearchRec.Old_Size]
        MOV	word ptr ES:[DI+XSearchRec.Size],AX
 	MOV	AX,word ptr ES:[DI+XSearchRec.Old_Size+2]
        MOV	word ptr ES:[DI+XSearchRec.Size+2],AX
        MOV	AL,byte ptr ES:[DI+XSearchRec.Old_Attr]
        MOV	AH,0
        MOV	word ptr ES:[DI+XSearchRec.Attr],AX
        MOV	AL,0
        MOV	word ptr ES:[DI+XSearchRec.Attr+2],AX
        ADD	DI,XSearchRec.Old_Name
        call    FixString
	XOR	AX,AX
        jmp	@@2


@Find95:LES     DI,Search
        MOV	BX,word ptr ES:DI+XSearchRec.FileFindHandle
        MOV	SI,1
        MOV	AX,$714F
        INT	21H
        JC	@@2
        LES	DI,Search
        MOV	AX,word ptr ES:[DI+XSearchRec.FileSizeLo]
        MOV	word ptr ES:[DI+XSearchRec.Size],AX
 	MOV	AX,word ptr ES:[DI+XSearchRec.FileSizeLo+2]
        MOV	word ptr ES:[DI+XSearchRec.Size+2],AX
        MOV	AX,word ptr ES:[DI+XSearchRec.Attributes]
        MOV	word ptr ES:[DI+XSearchRec.Attr],AX
        MOV	AX,word ptr ES:[DI+XSearchRec.Attributes+2]
        MOV	word ptr ES:[DI+XSearchRec.Attr+2],AX
        MOV	SI,DI
        ADD	DI,XSearchRec.FileName
        ADD	SI,XSearchRec.Name
        MOV	word ptr ES:SI,DI
        MOV	AX,ES
        MOV	word ptr ES:SI+2,AX
        call	FixString
	XOR	AX,AX

@@2:    MOV	DosError,AX
end;


{finishing long filename searching}
procedure FindClose2(var Search: XSearchRec); assembler;
asm
	mov	cl,byte ptr Win95
	or	cl,cl
        jz      @FindCloseExit

@Find95:LES     DI,Search
        MOV	BX,word ptr ES:DI+XSearchRec.FileFindHandle
        MOV	AX,$71A1
        INT	21H
        JC	@@2
@FindCloseExit:
        XOR	AX,AX
@@2:
	MOV	DosError,AX
end;



{file NoOperation procedure}
Function NoOp(var t:text):Word; assembler;
asm
	XOR	AX,AX
end;


{--------Advanced manipulation with TEXT--------}

{obtain file position mark from text}
Function FilePosText(var txt:text):longint; assembler;
asm
	push	ES
        les	SI,txt
	mov	AH,$42
	mov	DX,0
	mov	CX,0
	mov	AL,1		{ od soucasne pozice v souboru }
	mov	BX,ES:SI.file2.fhandle
	int	21h		{pozice je v DX:AX}

        cmp dx,0
        je @@1

	nop
@@1:
        add	AX,ES:SI.file2.fBufPos {DX:AX=DX:AX-t.BufEnd+t.BufPos}
        adc	DX,0
        sub	AX,ES:SI.file2.fBufEnd
        sbb	DX,0
 	pop	ES
end;


{obtain seek into the textfile asigned to text}
Procedure seekText(var txt:text;x:longint);
begin
 Flush(txt);
 	asm
       	push	ES
        les	SI,txt
	mov	DX,word ptr x
	mov	CX,word ptr x+2
        mov	BX,ES:SI.file2.fhandle
	mov	AL,0
	mov	AH,$42
        mov	ES:SI.file2.fbufPos,0
        mov	ES:SI.file2.fbufEnd,0
        int	21h
        pop	ES
        end;
end;


{read block from text}
Function BlockReadText(var txt:text;var buf;count:word):Word;
var i,n:word;
    Soubor:File2 absolute Txt;
    ptrB:^Byte;
begin
n:=0;
ptrB:=addr(buf);
while count>0 do
   begin
   if soubor.fbufEnd=soubor.fBufPos then
   	begin
        if system.inoutres=0 then
	        system.inoutres:=soubor.fInOutProc(txt);
        if soubor.fbufEnd=soubor.fBufPos then  {konec souboru}
                begin
                fillchar(ptrB^,count,0);
		Break;
                end;
        end;
   i:=soubor.fbufEnd-soubor.fBufPos;
   if count<=i then i:=count;
   move(ptr(seg(soubor.fBufPtr^),ofs(soubor.fBufPtr^)+soubor.fBufPos)^,ptrB^,i);

   inc(soubor.fBufPos,i);
   inc(ptrB,i);
   dec(count,i);
   inc(n,i);
   end;

BlockReadText:=n;
end;


Procedure AddBuffer(var Txt:Text;buf:pointer;size:Word);
var Soubor:File2 absolute Txt;
begin
if(buf=nil)or(size=0) then exit;
with Soubor do
  begin
  fBufPtr:=Buf;
  fBufSize:=Size;
  fBufPos:=0;
  fBufEnd:=0;
  end;
end;


{------zlepseni prace s textovym souborem------}
Function GetcharTXT(var txt:Text):char;
var pismeno:char;
begin
 read(txt,pismeno);
 GetcharTXT:=pismeno;
end;


Function ReadxByte(var Txt:Text):byte;
var c:char;
    b:byte;
begin
repeat               { dojede na pocatek cisla }
 if eof(txt) then exit;
 c:=UpCase(GetcharTXT(txt));
until ((c >= '0') and (c <= '9')) or ((c >= 'A') and (c <= 'F'));
asm     mov	al,c
	sub	al,'0'
	cmp	al,9
	jle	@@hxcif
	sub	al,'A'-'9'-1
@@hxcif:mov	cl,4
	shl	al,cl
	mov	b,al
end;
c:=UpCase(GetcharTXT(txt));
asm     mov	al,c
	sub	al,'0'
        cmp	al,9
        jle	@@hxcif
        sub	al,'A'-'9'-1
@@hxcif:add	al,b
        mov	b,al
end;
ReadxByte:=b;
end;


Function readInt(var txt:Text;var c:char):Word;	{precte integer ze souboru}
var i,NSystem:word;
    b:byte;
begin
readInt:=0;
while not((c >= '0') and (c <= '9')) do
	begin               { dojede na pocatek cisla }
	if eof(txt) then exit;
	c:=GetcharTXT(txt);
	end;
i:=0;                  { tady nactu cislo }
NSystem:=10;
if(c='0') then
   begin
   c:=GetcharTXT(txt);
   if(c='x') then
	begin
	NSystem:=16;
	c:=GetcharTXT(txt);
	end;
   end;
repeat
 if(c>'9') then
	begin
	b:=ord(upcase(c))-ord('A')+10;
	if(b<10) then break;
	end
 else b:=ord(c)-ord('0');
 if(b>=NSystem) then break;
 i:=NSystem*i + b;
 if(eof(txt)) then break;
 c:=GetcharTXT(txt);
until false;
readInt:=i;
end;


Function readLong(var txt:Text;var c:char):longint;	{precte longint ze souboru}
var i,NSystem:longint;
    b:byte;
begin
readLong:=0;
while not((c >= '0') and (c <= '9')) do
	begin               { dojede na pocatek cisla }
	if eof(txt) then exit;
	c:=GetcharTXT(txt);
	end;
i:=0;                  { tady nactu cislo }
NSystem:=10;
if(c='0') then
   begin
   c:=GetcharTXT(txt);
   if(c='x') then
	begin
	NSystem:=16;
	c:=GetcharTXT(txt);
	end;
   end;
repeat
 if(c>'9') then
	begin
	b:=ord(upcase(c))-ord('A')+10;
	if(b<10) then break;
	end
 else b:=ord(c)-ord('0');
 if(b>=NSystem) then break;
 i:=NSystem*i + b;
 c:=GetcharTXT(txt);
until eof(txt);
readLong:=i;
end;


Function readWord(var txt:Text;var c:char):string;
var s:string;
label 1;
begin
s:='';
repeat               { dojede na pocatek slova }
 if eof(txt) then GoTo 1;
 c:=GetcharTXT(txt);
until ((c<>' ') and (c<>#10))  and ((c<>#13) and (c<>#9));
while ((c<>' ') and (c<>#10))  and ((c<>#13) and (c<>#9)) do
   begin
   s:=s+c;
   if eof(txt) then Goto 1;
   c:=GetcharTXT(txt);
   end;
1:
readWord:=s;
end;


procedure WritexByte (w:byte;var txt:text);
var c:array [1..2] of char;
begin
	asm
        mov	al,w
        mov	ah,al
        mov	cl,4
        shr	ah,cl
        and	al,0Fh
        add	al,90h
        daa
        adc	al,40h
        daa
	mov	byte ptr c + 1 ,al
        mov	al,ah
        add	al,90h
        daa
        adc	al,40h
        daa
        mov	byte ptr c,al
	end;
  Write(txt,c)
end;


Procedure ReadLn2(var txt:text);
var c:char;
begin
 repeat
   if eof(txt) then exit;
   c:=GetCharTxt(txt);
 until (c=#10) or (c=#13)
end;


{^^^^^^^^^ Startup initialisation ^^^^^^^^^^^^^^ uvodni inicializace }
function CheckLongNames:Boolean;
var check:Boolean;
{$ifdef P386}
    P:pointer;
    RealSeg:Word;
    r:registers386;
begin
 check:=false;
 r.AH:=$30;
 DPMI_Intr($21,r);
 if r.AL=7 then
    begin
    P:=DOS_GetMem(512,RealSeg);
    r.DS:=RealSeg;
    r.SI:=ofs(p^);	{tohle je nejake divne - overit}
    r.AX:=$7147;		{get current directory}
    r.DL:=0;
    DPMI_Intr($21,r);
    DOS_FreeMem(P);
    if r.AX<>$7100 then check:=True;
    end;
{$else}
    P:pointer;
    data:array[0..256] of char;
begin
check:=false;
P:=addr(data);
	asm
	mov	ah,30h
	int	21h		{get Dos Version}
	cmp	al,7
	jl      @NoSup

	push	ds
	mov	si,word ptr[P]
	mov	ax,word ptr[P+2]
	mov	ds,ax
	mov	ax,7147h	{get current directory}
	mov	dl,0
	int     21h
	pop	ds

	cmp	ax,7100h
	je	@NoSup
	mov	check,not 0
@NoSup: end;
{$endif}
  CheckLongNames:=check;
{  CheckLongNames:=false;{}
end;


Procedure string2Pchar(var as_);
var i:integer;
    astring:String absolute As_;
begin
 i:=length(Astring);
 Move(Astring[1],Astring[0],i);
 Astring[i]:=#0;
end;


Procedure Pchar2String(var as_);
var i:integer;
    astring:String absolute As_;
begin
 i:=0;
 while Astring[i]<>#0 do inc(i);
 if i>255 then RunError(255);
 Move(Astring[0],Astring[1],i);
 Astring[0]:=chr(i);
end;

{$W+}

function FileSplit2(Path, Dir, Name, Ext: PChar): Word;
var
  DirLen, NameLen, ExtLen, Flags: Word;
  NamePtr, ExtPtr: PChar;
begin
  NamePtr := StrRScan(Path, '\');
  if NamePtr = nil then NamePtr := StrRScan(Path, ':');
  if NamePtr = nil then NamePtr := Path else Inc(NamePtr);
  ExtPtr := StrScan(NamePtr, '.');
  if ExtPtr = nil then ExtPtr := StrEnd(NamePtr);
  DirLen := NamePtr - Path;
{  if DirLen > fsDirectory then DirLen := fsDirectory;}
  NameLen := ExtPtr - NamePtr;
{  if NameLen > fsFilename then NameLen := fsFilename;}
  ExtLen:= StrEnd(NamePtr) - ExtPtr;
  Flags := 0;
  if (StrScan(NamePtr, '?') <> nil) or (StrScan(NamePtr, '*') <> nil) then
    Flags := fcWildcards;
  if DirLen <> 0 then Flags := Flags or fcDirectory;
  if NameLen <> 0 then Flags := Flags or fcFilename;
  if ExtPtr[0] <> #0 then Flags := Flags or fcExtension;
  if Dir <> nil then StrLCopy(Dir, Path, DirLen);
  if Name <> nil then StrLCopy(Name, NamePtr, NameLen);
  if Ext <> nil then StrLCopy(Ext, ExtPtr, ExtLen);
  FileSplit2 := Flags;
end;

{$W-}

Procedure FSplit2(Path: string;var Dir:string; var Name:string;var Ext:string);
begin
 string2Pchar(Path);
 FileSplit2(@Path,@Dir,@Name,@Ext);
 pchar2string(Dir);
 pchar2string(Name);
 pchar2string(Ext);
end;


begin
  Win95:=CheckLongNames;
end.



{---------------puvodni zatim nevyuzivane zdrojaky v Pascalu--------------}
Function FilePosText(var txt:text):longint;
var r:Registers;
    t:textrec absolute txt;
begin
 r.AH:=$42;
 r.DX:=0;
 r.CX:=0;
 r.AL:=1;  { od soucasne pozice v souboru }
 r.BX:=t.handle;
 msDOS(r);
 FilePosText:=(r.AX+65536*r.DX)-t.BufEnd+t.BufPos;
end;


Procedure seekText(var txt:text;x:longint);
var r:Registers;
    t:textrec absolute txt;
begin
 Flush(text(t));
 r.DX:=word(x);
 r.CX:=x div 65536;
 r.BX:=t.handle;
 r.AL:=0;
 r.AH:=$42;
 t.BufPos:=0;
 t.BufEnd:=0;
 msDOS(r);
end;

